home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HWRIBBON.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  8.9 KB  |  340 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2.  
  3. {**********************************************}
  4. {                                              }
  5. {   HeapSpy - HWRibbon Module                  }
  6. {   Copyright (c) 1992  Borland International  }
  7. {                                              }
  8. {**********************************************}
  9.  
  10. unit HWRibbon;
  11.  
  12. {$C MOVEABLE PRELOAD PERMANENT}
  13.  
  14. interface
  15.  
  16. uses WinTypes, WinProcs, OWindows, ODialogs, Strings, HWGlobal;
  17.  
  18. type
  19.   PRibbonWindow = ^TRibbonWindow;
  20.   TRibbonWindow = object(TWindow)
  21.     GrayBrush: HBrush;
  22.     GrayPen, WhitePen: HPen;
  23.     Height: Integer;
  24.     HintText: array[0..80] of Char;
  25.     Font: HFont;
  26.     IsStockFont: Boolean;
  27.     DefaultText: PChar;
  28.     constructor Init(AParent: PWindowsObject);
  29.     destructor Done; virtual;
  30.     function GetClassName: PChar; virtual;
  31.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  32.     procedure Paint(PaintDC: hDC; var PS: TPaintStruct); virtual;
  33.     procedure SetHelpText(Txt: PChar);
  34.     procedure WMSetText(var Msg: TMessage);
  35.       virtual wm_First + wm_SetText;
  36.   end;
  37.  
  38.   PSpeedButton = ^TSpeedButton;
  39.   TSpeedButton = object(TButton)
  40.     BMP: hBitmap;
  41.     Width,Height: word;
  42.     constructor Init(AParent: PWindowsObject; AnID: Integer; x,y: Integer;
  43.       ABitMap: PChar);
  44.     destructor Done; virtual;
  45.     function GetClassName: PChar; virtual;
  46.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  47.     procedure WMLButtonDown(var Msg: TMessage);
  48.       virtual wm_First + wm_LButtonDown;
  49.     procedure WMLButtonUp(var Msg: TMessage);
  50.       virtual wm_First + wm_LButtonUp;
  51.   end;
  52.  
  53.   PSpeedBar = ^TSpeedBar;
  54.   TSpeedBar = object(TWindow)
  55.     StatusLine: PWindowsObject;
  56.     constructor Init(AParent: PWindowsObject; AStatusLine: PWindowsObject);
  57.     function GetClassName: PChar; virtual;
  58.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  59.     procedure AddATool(AnID: Word; ABitMap: PChar);
  60.     procedure WMDrawItem(var Msg: TMessage);
  61.       virtual wm_First + wm_DrawItem;
  62.     procedure WMSetFocus(var Msg: TMessage);
  63.       virtual wm_First + wm_SetFocus;
  64.     procedure WMCommand(var Msg: TMessage);
  65.       virtual wm_First + wm_Command;
  66.   end;
  67.  
  68. implementation
  69.  
  70. constructor TRibbonWindow.Init(AParent: PWindowsObject);
  71. var
  72.   DC: hDC;
  73.   OldFont: HFont;
  74.   TM: TTExtMetric;
  75.   LogFont: TLogFont;
  76. const
  77.   WVSRec: record
  78.     MajorV,
  79.     MinorV,
  80.     RevChar: Word;
  81.     Copr: PChar;
  82.   end = (
  83.     MajorV:0;
  84.     MinorV:0;
  85.     RevChar:0;
  86.     Copr:'Copyright ⌐ 1992 Borland International');
  87. begin
  88.   { basic initialization for a non-MDI Window in an MDI Frame }
  89.   Inherited Init(AParent, '');      { create the window normally }
  90.   HintText[0] := #0;
  91.   SetFlags(wb_MDIChild, False);     { turn off the MDI flag that TWindow set }
  92.   DefaultProc := @DefWindowProc;    { and redirect the DefaultProc back }
  93.   Attr.Style := ws_Border or ws_Child or ws_Visible;
  94.  
  95.   { establish Font for use in this window }
  96.   Font := GetStockObject(ANSI_VAR_FONT);
  97.   GetObject(Font,Sizeof(TLogFont), @LogFont);
  98.   LogFont.lfWeight := 700;
  99.   Font :=CreateFontIndirect(LogFont);
  100.   IsStockFont := false;
  101.  
  102.   { Determine the height of this window }
  103.   DC := GetDC(0);
  104.   OldFont := SelectObject(DC, Font);
  105.   GetTextMetrics(DC, TM);
  106.   Height := TM.tmHeight + 8;
  107.   SelectObject(DC, OldFont);
  108.   ReleaseDC(0, DC);
  109.  
  110.   { Make the pens and brushes used to draw the status line }
  111.   GrayPen := CreatePen(PS_SOLID,1,$00808080);
  112.   WhitePen := CreatePen(PS_Solid,1,$00FFFFFF);
  113.   GrayBrush := CreateSolidBrush($00C0C0C0);
  114.  
  115.   { Set up the text displayed in the hint line when there's nothing
  116.     of greater importance to display }
  117.    WVSrec.MajorV := MajorVersion;
  118.    WVSRec.MinorV := MinorVersion;
  119.    WVSRec.RevChar := Byte(RevisionChar);
  120.    WVSPrintf(HintText,'HeapSpy v%i.%#02i%c %s',WVSRec);
  121.    DefaultText := StrNew(HintText);
  122.    HintText[0] := #0;
  123. end;
  124.  
  125. destructor TRibbonWindow.Done;
  126. begin
  127.   DeleteObject(GrayPen);
  128.   DeleteObject(WhitePen);
  129.   StrDispose(DefaultText);
  130.   { -- this object is still part of the class, so don't delete!!
  131.   DeleteObject(GrayBrush);
  132.   }
  133.   if not IsStockFont then DeleteObject(Font);
  134.   inherited Done;
  135. end;
  136.  
  137. function TRibbonWindow.GetClassName;
  138. begin
  139.   GetClassName := 'StatusWindow';
  140. end;
  141.  
  142. procedure TRibbonWindow.GetWindowClass(var WndClass: TWndClass);
  143. begin
  144.   inherited GetWindowClass(WndClass);
  145.   WndClass.hbrBackGround := GrayBrush;
  146. end;
  147.  
  148. procedure TRibbonWindow.Paint;
  149. var
  150.   OldFont: HFont;
  151.   OldPen : hPen;
  152.   R: TRect;
  153. begin
  154.   GetClientRect(hWindow,R);
  155.   with R do
  156.   begin
  157.     Inc(Left,4); Inc(top,2); Dec(Right,4);
  158.     Dec(Bottom,3);
  159.     SetBKMode(PaintDC, Transparent);
  160.     OldPen := SelectObject(PaintDC, GrayPen);
  161.     MoveTo(PaintDC, left,bottom);
  162.     LineTo(PaintDC, left,top);
  163.     LineTo(PaintDC, right,top);
  164.     SelectObject(PaintDC, WhitePen);
  165.     LineTo(PaintDC, right,bottom);
  166.     LineTo(PaintDC, left,bottom);
  167.   end;
  168.   SelectObject(PaintDC, OldPen);
  169.   SetTextColor(PaintDC, 0);
  170.   OldFont := SelectObject(PaintDC, Font);
  171.   with R do
  172.     IntersectClipRect(PaintDC, left, top, right-2, bottom);
  173.   if HintText[0] <> #0 then
  174.     TextOut(PaintDC, 8, 3, HintText, StrLen(HintText))
  175.   else
  176.     TextOut(PaintDC, 8, 3, DefaultText, StrLen(DefaultText));
  177.   SelectObject(PaintDC,OldFont);
  178. end;
  179.  
  180. procedure TRibbonWindow.SetHelpText;
  181. begin
  182.   if Txt = nil then
  183.     HintText[0] := #0
  184.   else
  185.     StrLCopy(HintText, Txt, 80);
  186.   if hWindow <> 0 then
  187.     InvalidateRect(hWindow, nil, True);
  188. end;
  189.  
  190. procedure TRibbonWindow.WMSetText;
  191. begin
  192.   SetHelpText(PChar(Msg.lPAram));
  193. end;
  194.  
  195. constructor TSpeedButton.Init(AParent: PWindowsObject; AnID: Integer;
  196.   x,y: Integer; ABitMap: PChar);
  197. var
  198.   B: TBitMap;
  199. begin
  200.   BMP := LoadBitMap(hInstance,ABitMap);
  201.   if BMP = 0 then Fail;
  202.   GetObject(BMP,Sizeof(B), @B);
  203.   Width := B.bmWidth;
  204.   Height := B.bmHeight;
  205.   inherited Init(AParent, AnID, '', x, y, Width, Height, False);
  206.   Attr.Style := Attr.Style or bs_OwnerDraw;
  207. end;
  208.  
  209. destructor TSpeedButton.Done;
  210. begin
  211.   inherited Done;
  212.   if BMP <> 0 then DeleteObject(BMP);
  213. end;
  214.  
  215. function TSpeedButton.GetClassName: PChar;
  216. begin
  217.   GetClassName := 'Button';
  218. end;
  219.  
  220. procedure TSpeedButton.GetWindowClass(var WndClass: TWndClass);
  221. begin
  222.   inherited GetWindowClass(WndClass);
  223. end;
  224.  
  225. procedure TSpeedButton.WMLButtonDown;
  226. var
  227.   HelpText: array[0..80] of Char;
  228. begin
  229.   if PSpeedBar(Parent)^.StatusLine <> nil then
  230.   begin
  231.     HelpText[0] := #0;
  232.     LoadString(hInstance,Attr.ID,HelpText,80);
  233.     SendMessage(PSpeedBar(Parent)^.StatusLine^.hWindow,
  234.       wm_SetText, 0, LongInt(@HelpText));
  235.   end;
  236.   DefWndProc(Msg);
  237. end;
  238.  
  239. procedure TSpeedButton.WMLButtonUp;
  240. begin
  241.    if PSpeedBar(Parent)^.StatusLine <> nil then
  242.      SendMessage(PSpeedBar(Parent)^.StatusLine^.hWindow,
  243.        wm_SetText, 0, 0);
  244.    DefWndProc(Msg);
  245. end;
  246.  
  247. { Speedbar Methods }
  248.  
  249. constructor TSpeedBar.Init;
  250. var
  251.   i: Integer;
  252. begin
  253.   inherited Init(AParent,'');
  254.   StatusLine := AStatusLine;
  255.   Flags := Flags and (not wb_MDIChild);
  256.   DefaultProc := @DefWindowProc;
  257.   Attr.X := 0;
  258.   Attr.Y := 0;
  259.   Attr.W := 2;
  260.   Attr.H := 0;
  261.   Attr.Style := ws_Visible or ws_Child or ws_Border;
  262. end;
  263.  
  264. function TSpeedBar.GetClassName: PChar;
  265. begin
  266.   GetClassName := 'SpeedBar';
  267. end;
  268.  
  269. procedure TSpeedBar.GetWindowClass(var WndClass: TWndClass);
  270. begin
  271.   inherited GetWindowClass(WndClass);
  272.   with WndClass do
  273.     hbrBackGround := GetStockObject(LtGray_Brush);
  274. end;
  275.  
  276. procedure TSpeedBar.AddATool(AnID: Word; ABitMap: PChar);
  277. var
  278.   Tool: PSpeedButton;
  279.   NewWidth,i,x,y,Col: Integer;
  280. begin
  281.   x := Attr.W;
  282.   y := 2;
  283.   Tool := New(PSpeedButton,Init(@Self,AnID,x,y,ABitMap));
  284.   if Tool = nil then exit;
  285.   Inc(Attr.W,(Tool^.Width+2));
  286.   if Attr.H < (Tool^.Height+6) then
  287.     Attr.H := Tool^.Height+6;
  288. end;
  289.  
  290. procedure TSpeedBar.WMDrawItem(var Msg: TMessage);
  291. var
  292.   Tool: PSpeedButton;
  293.   MemDC: hDC;
  294.   OldBMP: hBitmap;
  295.   x,y: Integer;
  296. begin
  297.   with PDrawItemStruct(Msg.lParam)^ do
  298.   begin
  299.     Tool := PSpeedButton(ChildWithID(CtlID));
  300.     MemDC := CreateCompatibleDC(hDC);
  301.     OldBMP := SelectObject(MemDC,Tool^.BMP);
  302.     if (ItemState and ODS_Selected) <> 0 then
  303.     begin
  304.       x := 1;
  305.       y := 1;
  306.     end
  307.     else
  308.     begin
  309.       x := 0;
  310.       y := 0;
  311.     end;
  312.     BitBlt(hDC, x, y, Tool^.Width - x * 2, Tool^.Height - y * 2, MemDC,
  313.       0, 0, SrcCopy);
  314.     SelectObject(MemDC,OldBMP);
  315.     DeleteDC(MemDC);
  316.   end;
  317. end;
  318.  
  319. procedure TSpeedBar.WMSetFocus;
  320. begin
  321.   SetFocus(Msg.wParam);
  322. end;
  323.  
  324. procedure TSpeedBar.WMCommand(var Msg: TMessage);
  325. var
  326.   MDIChild,MDIClient: hWnd;
  327. begin
  328.   if DescendantOf(TypeOf(TMDIWindow),TypeOf(Application^.MainWindow^)) then
  329.   begin
  330.     MDIClient := PMDIWindow(Application^.MainWindow)^.ClientWnd^.hWindow;
  331.     MDIChild := SendMessage(MDIClient,WM_MDIGetActive,0,0);
  332.     if MDIChild = 0 then MDIChild := MDIClient;
  333.   end
  334.   else
  335.      MDIChild := Application^.MainWindow^.hWindow;
  336.   SendMessage(MDIChild,WM_COMMAND,Msg.wParam,0);
  337. end;
  338.  
  339. end.
  340.